#!/usr/bin/perl

package PerLISP::Eval;

require Exporter;

use strict;
use warnings;
use feature ':5.10';

use PerLISP::Cons;
use PerLISP::LispOps qw( :DEFAULT );

our @ISA = qw( Exporter );
our @EXPORT = qw ( _evalquote );
our @EXPORT_OK;

sub _apply;
sub _eval;
sub _parlis;
sub _assoc;
sub _evcon;


sub _pairlis {
  my ($x, $y, $a) = @_;
  until ( _nill( $x ) or _nill( $y )) {
    $a = _cons( _cons( _car( $x ), _car( $y )), $a );
    $x = _cdr( $x );
    $y = _cdr( $y );
  }
  return $a;
}

sub _assoc {
  my ($x, $a) = @_;
  if ( $x eq _caar( $a )) {
    return _car( $a );
  }
  else {
    return _assoc( $x, _cdr( $a ));
  }
}

sub _evcon {
  my ($c, $a ) = @_;
  if ( _eval( _caar( $c ), $a )) {
    _eval( _cadar( $c ), $a );
  }
  else {
    _evcon( _cdr( $c ), $a );
  }
}

sub _evlis {
  my ($m, $a) = @_;
  if ( _nill( $m )) {
    return '';
  }
  else {
    _cons( _eval( _var( $m ), $a ), _evalis( _cdr( $m ), $a ));
  }
}


sub _apply {
  my ($fn, $x, $a) = @_;
  if ( _atomic( $fn )) {
    given ( $fn ) {
      when ( /CAR/ ) {
        return _caar( $x );
      }
      when ( /CDR/ ) {
        return _cdar( $x );
      }
      when ( /CONS/ ) {
        return _cons( _car( $x ), _cadr( $x ));
      }
      when ( /ATOM/ ) {
        return _atomic( _car( $x ));
      }
      when ( /EQ/ ) {
        return 'T' if ( _eq( _car( $x ), _cadr( $x )));
        return 'F';
      }
      when ( /LIST/ ) {
        return $x;
      }
      default {
        return _apply( _eval( $fn, $a ), $x, $a );
      }
    }
  }
  elsif ( _car( $fn ) =~ /LAMBDA/ ) {
    return _eval( _caddr( $fn ), _pairlis( _cadr( $fn ), $x, $a));
  }
  elsif ( _car( $fn ) =~ /LABEL/ ) {
    return _apply( _caddr( $fn ), $x, _cons( _cons( _cadr( $fn ), caddr( $fn )), $a));
  }
}

sub _eval {
  my ($e, $a) = @_;
  if ( _atomic( $e )) {
    return _cdr( _assoc( $e, $a ));
  }
  elsif ( _atomic( _car( $e )))  {
    given ( _car( $e )) {
      when ( /QUOTE/ ) {
        return _cadr( $e );
      }
      when ( /COND/ ) {
        return _evcond( _cdr( $e ), $a );
      }
      default {
        return _apply( _car( $e ), _evlis( _cdr( $e ), $a), $a);
      }
    }
  }
  else {
    return _apply( _car( $e ), _evlis( _cdr( $e ), $a), $a);
  }
}

sub _evalquote {
  my ($fn, $x) = @_;
  return _apply( $fn, $x, undef );
}

1;
__END__
